home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / error.t < prev    next >
Text File  |  1988-02-05  |  8KB  |  220 lines
  1. (herald error (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;++ Someday we should include an explanitory index of error messages
  27. ;++ in the manual.  In order to do this the errors should have
  28. ;++ reasonably short explanitory names.
  29. ;++
  30. ;++ Errors really want to be printed with a prefix format.  We really
  31. ;++ need something like Water's PP.
  32.  
  33. (define internal-error-notice
  34.   #.(format nil "~%~a~%~a~%~a~%~a~%"
  35.       "****"
  36.       "****    This is an internal error. Please inform the"
  37.       "****    implementors by sending mail to T3-BUGS@YALE."
  38.       "****"))
  39.  
  40. ;;; VM-ERROR is called only inside the Virtual Machine.  It indicates
  41. ;;; that something is seriously amiss.  If the Z-SYSTEM is present
  42. ;;; we try to use it to give an error message.  If an error is
  43. ;;; encountered while the GUARD is set or if the Z-SYSTEM isn't
  44. ;;; present we punt to FATAL-ERROR which does whatever the local-os
  45. ;;; allows.
  46.  
  47.  
  48. (define vm-error
  49.   (let ((guard  nil)
  50.         (notice? '#t))
  51.     (lambda (type fmt . args)
  52.       (cond ((and (z-system-present?) (not guard))
  53.              (bind ((*z?*  t)
  54.                     (guard t))
  55.                (let ((out (error-output)))
  56.                  (z-format out "~%** VM Error (~a): " type)
  57.                  (apply z-format out fmt args)
  58.                  (if notice? (vm-write-string out internal-error-notice))
  59.                  (vm-force-output out)))
  60.              (bind ((notice? '#f))
  61.                (z-breakpoint)))
  62.             (else
  63.              ;; punt to the machine debugger
  64.              (let ((out (error-output)))
  65.                (vm-newline out)
  66.                (vm-write-string out "** VM Error while reporting error!")
  67.                (vm-write-string out internal-error-notice)
  68.                (fatal-error)))))))
  69.  
  70. ;++ Move this to the local os hardware exception module.
  71.  
  72. ;++ When the system is more robust (VM-ERROR-OUTPUT) should be
  73. ;++ a broadcast port which writes both to (ERROR-OUTPUT) and to
  74. ;++ (VM-ERROR-LOG) a file in the (THE-T-SYSTEM-DIRECTORY).
  75. ;++ A log entry should consist of (VM-VERSION), (DATE&TIME),
  76. ;++ and any arguments to the call to VM-LOG.
  77.  
  78. ;(define (vm-log . args)
  79. ;  (apply vm-write (vm-error-log) (vm-version) (date&time) args))
  80.  
  81. ;;; Fatal error
  82. ;++ This routine should go to the machine debugger if it can.
  83. ;++ Someday maybe it will do a core dump (and/or checkpoint).
  84.  
  85. (define (fatal-error) (exit))
  86.  
  87. ;;; This error is called if a hardware exception occurs while control
  88. ;;; is inside the critical region of the hardware exception handler.
  89. ;;; See the local os hardware exception module.
  90.  
  91. ;;;  Errors detected by ICALL 
  92.  
  93. (define (icall-bad-proc p args)
  94.   (let* ((proc (or (identification p) p))
  95.          (fmt  (cond ((not (reasonable? proc))
  96.                       "attempt to call a corrupt datum~%**~10t~s")
  97.                      ((symbol? proc)               ; Cater to the confused
  98.                       "attempt to call a symbol or nonvalue~%**~10t~s")
  99.                      (else 
  100.                       "attempt to call a non-procedure~%**~10t~s"))))
  101.     (apply (error fmt (cons proc args)) args)))
  102.  
  103. (define (icall-wrong-nargs p args)
  104.   (let* ((n     (car (argspectrum p)))
  105.          (nary? (cdr (argspectrum p)))
  106.          (id    (cond ((identification p))
  107.                       (else
  108.                        (format nil "#{object internal to ~a}"
  109.                                (get-proc-name (extend-header p)))))))
  110.     (error (list "wrong number of arguments to procedure -~%"
  111.                  "**~10t~a~%**~10t~a takes~a ~a argument~p.~%")
  112.            (cons id args)
  113.            id
  114.            (if nary? " at least" "")
  115.            n
  116.            n)))
  117.  
  118. (define (cont-wrong-nargs p . args)
  119.   (let* ((m     (length args))
  120.          (n     (car (argspectrum p)))
  121.          (nary? (cdr (argspectrum p))))
  122.     (error "returned ~a value~p when~a ~a ~a expected -~%**~10t~s~%"
  123.            m            
  124.            m
  125.            (if nary? " at least" "")
  126.            n
  127.            (if (fx= n 1) "was" "were")
  128.            (cons (or (identification p) p) args))))
  129.  
  130. (define (apply-too-many-args proc) 
  131.   (nc-error "exceeded maximum number of arguments while applying ~a"
  132.             proc))
  133.  
  134. (define (handle-undefined-effect string template)
  135.   (nc-error "undefined effect - ~a ~%**~10tin procedure ~s~%"
  136.             string
  137.             (or (get-proc-name template) 'anonymous)))
  138.  
  139. (define (heap-overflow-error)
  140.   (nc-error "heap overflow"))
  141.  
  142. (define (undefined-effect . stuff)
  143.   (error "call to ~s~%  ~s" 'undefined-effect `(undefined-effect . ,stuff)))
  144.  
  145. (define (error fmt . args)
  146.   (if (not *z?*)
  147.       (signal-error *unspecific-error-type* fmt args)
  148.       (apply vm-error 'Z fmt args)))
  149.  
  150. (define (non-continuable-error fmt . args)
  151.   (if (not *z?*)
  152.       (signal-error *non-continuable-error-type* fmt args)
  153.       (apply vm-error 'ZNC fmt args))
  154.   (not-continuable))
  155.  
  156. (define nc-error non-continuable-error)
  157.  
  158. (define (not-continuable)
  159.   (error "The error you encountered is not continuable.")
  160.   (breakpoint)
  161.   (not-continuable))
  162.  
  163.  
  164. ;;; Warnings.
  165.  
  166. (define (warning fmt . args)
  167.   (let* ((flag (warn))
  168.          (out  (cond ((false? flag) (null-port))
  169.                      (else          (error-output)))))
  170.     (format out "~&;** Warning: ")
  171.     (apply format out fmt args)
  172.     (fresh-line out)
  173.     (if (eq? flag 'break) (breakpoint) (no-value))))
  174.  
  175. ;;; Three settings true, false, or 'BREAK.
  176.  
  177. ;++ need a better name, maybe break-on-warning
  178. (define-simple-switch warn
  179.   (lambda (val)
  180.     (or (eq? val '#f) (eq? val '#t) (eq? val 'break)))
  181.   '#t)
  182.  
  183. ;;; Language level errors.
  184.  
  185. (define (losing-xcond)
  186.   (error "no clause selected in ~s expression" 'xcond))
  187.  
  188. (define (losing-xcase)
  189.   (error "no clause selected in ~s expression" 'xcase))
  190.  
  191. (define (losing-xselect)
  192.   (error "no clause selected in ~s expression" 'xselect))
  193.  
  194.  
  195. ;;; Undefined values
  196.  
  197. (define (undefined-value . stuff)
  198.   (cond ((null? stuff)
  199.          ;; Don't close over STUFF
  200.          (object nil
  201.                  ((print self port)
  202.                   (format port "#{Undefined-value~_~a}"
  203.                           (object-hash self)))))
  204.         (else
  205.          (object nil
  206.                  ((print self port)
  207.                   (format port "#{Undefined-value~_~a"
  208.                           (object-hash self))
  209.                   (walk (lambda (x) (format port "~_~a" x))
  210.                         stuff)
  211.                   (write-char port #\}))))))
  212.  
  213.  
  214. (define undefined-if-value      (undefined-value "undefined IF value"))
  215. (define unbound-label           (undefined-value "unbound label"))
  216. (define let-missing-initializer (undefined-value "LET missing initializer"))
  217. (define no-more-cond-clauses    (undefined-value "no more COND clauses"))
  218. (define case-fell-off-end       (undefined-value "CASE fell off end"))
  219. (define select-fell-off-end     (undefined-value "SELECT fell off end"))
  220.